home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / FASDUMP.C < prev    next >
C/C++ Source or Header  |  1992-02-18  |  16KB  |  562 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /tmp/scm386/microcode/RCS/fasdump.c,v 9.53 1992/02/18 17:30:34 jinx Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This file contains code for fasdump and dump-band. */
  36.  
  37. #include "scheme.h"
  38. #include "prims.h"
  39. #include "osio.h"
  40. #include "osfile.h"
  41. #include "osfs.h"
  42. #define In_Fasdump
  43. #include "gccode.h"
  44. #include "trap.h"
  45. #include "lookup.h"
  46. #include "fasl.h"
  47.  
  48. static Tchannel dump_channel;
  49.  
  50. #define Write_Data(size, buffer)                    \
  51.   ((OS_channel_write_dump_file                        \
  52.     (dump_channel,                            \
  53.      ((char *) (buffer)),                        \
  54.      ((size) * (sizeof (SCHEME_OBJECT)))))                \
  55.    / (sizeof (SCHEME_OBJECT)))
  56.  
  57. #include "dump.c"
  58.  
  59. extern SCHEME_OBJECT
  60.   EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
  61.   * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
  62.   * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
  63.   * EXFUN (cons_whole_primitive_table,
  64.        (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  65.  
  66. /* Some statics used freely in this file */
  67.  
  68. static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
  69. static Boolean compiled_code_present_p;
  70. static CONST char * dump_file_name = ((char *) 0);
  71.  
  72. /* FASDUMP:
  73.  
  74.    Hair squared! ... in order to dump an object it must be traced (as
  75.    in a garbage collection), but with some significant differences.
  76.    First, the copy must have the global value cell of symbols set to
  77.    UNBOUND and variables uncompiled.  Second, and worse, all the
  78.    broken hearts created during the process must be restored to their
  79.    original values.  This last is done by growing the copy of the
  80.    object in the bottom of spare heap, keeping track of the locations
  81.    of broken hearts and original contents at the top of the spare
  82.    heap.
  83.  
  84.    FASDUMP is called with three arguments:
  85.    Argument 1: Object to dump.
  86.    Argument 2: File name.
  87.    Argument 3: Flag.
  88.    Currently, flag is ignored.
  89. */
  90.  
  91. /*
  92.    Copy of GCLoop, except (a) copies out of constant space into the
  93.    object to be dumped; (b) changes symbols and variables as
  94.    described; (c) keeps track of broken hearts and their original
  95.    contents (e) To_Pointer is now NewFree.
  96. */
  97.  
  98. #define Setup_Pointer_for_Dump(Extra_Code)                \
  99.   Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, Normal_BH (false, continue)))
  100.  
  101. #define Dump_Pointer(Code)                        \
  102.   Old = (OBJECT_ADDRESS (Temp));                    \
  103.   Code
  104.  
  105. /* This depends on the fact that the last word in a compiled code block
  106.    contains the environment, and that To will be pointing to the word
  107.    immediately after that!
  108.  */
  109.  
  110. #define Fasdump_Transport_Compiled()                    \
  111. {                                    \
  112.   Transport_Compiled();                            \
  113.   if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT))    \
  114.   {                                    \
  115.     *(To - 1) = SHARP_F;                        \
  116.   }                                    \
  117. }
  118.  
  119. #define Dump_Compiled_Entry(label)                        \
  120. {                                        \
  121.   Dump_Pointer (Fasdump_Setup_Pointer (Fasdump_Transport_Compiled (),        \
  122.                        Compiled_BH (false, goto label)));    \
  123. }
  124.  
  125. /* Should be big enough for the largest fixed size object (a Quad)
  126.    and 2 for the Fixup.
  127.  */
  128.  
  129. #define FASDUMP_FIX_BUFFER 10
  130.  
  131. long
  132. DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode)
  133. {
  134.   fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes;
  135.   long result;
  136.  
  137.   To = NewFree;
  138.   Fixes = Fixup;
  139.  
  140.   for ( ; Scan != To; Scan++)
  141.   {
  142.     Temp = *Scan;
  143.  
  144.     Switch_by_GC_Type (Temp)
  145.     {
  146.       case TC_PRIMITIVE:
  147.       case TC_PCOMB0:
  148.         *Scan = dump_renumber_primitive(*Scan);
  149.     break;
  150.  
  151.       case TC_BROKEN_HEART:
  152.         if (OBJECT_DATUM (Temp) != 0)
  153.     {
  154.       sprintf (gc_death_message_buffer,
  155.            "dumploop: broken heart (0x%lx) in scan",
  156.            ((long) Temp));
  157.       gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
  158.       /*NOTREACHED*/
  159.     }
  160.     break;
  161.  
  162.       case TC_MANIFEST_NM_VECTOR:
  163.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  164.     Scan += (OBJECT_DATUM (Temp));
  165.     break;
  166.  
  167.       /* Compiled code relocation. */
  168.  
  169.       case_compiled_entry_point:
  170.     compiled_code_present_p = true;
  171.     Dump_Compiled_Entry (after_entry);
  172.       after_entry:
  173.     *Scan = Temp;
  174.     break;
  175.  
  176.       case TC_MANIFEST_CLOSURE:
  177.       {
  178.     fast long count;
  179.     fast char *word_ptr;
  180.     SCHEME_OBJECT *area_end;
  181.  
  182.     compiled_code_present_p = true;
  183.     START_CLOSURE_RELOCATION (Scan);
  184.     Scan += 1;
  185.     count = (MANIFEST_CLOSURE_COUNT (Scan));
  186.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
  187.     area_end = (MANIFEST_CLOSURE_END (Scan, count));
  188.  
  189.     while ((--count) >= 0)
  190.     {
  191.       Scan = ((SCHEME_OBJECT *) (word_ptr));
  192.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  193.       EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  194.       Dump_Compiled_Entry (after_closure);
  195.     after_closure:
  196.       STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  197.     }
  198.     Scan = area_end;
  199.     END_CLOSURE_RELOCATION (Scan);
  200.     break;
  201.       }
  202.  
  203.       case TC_LINKAGE_SECTION:
  204.       {
  205.     compiled_code_present_p = true;
  206.     switch (READ_LINKAGE_KIND (Temp))
  207.     {
  208.       case REFERENCE_LINKAGE_KIND:
  209.       case ASSIGNMENT_LINKAGE_KIND:
  210.       {
  211.         /* Assumes that all others are objects of type TC_QUAD without
  212.            their type codes.
  213.          */
  214.  
  215.         fast long count;
  216.  
  217.         Scan++;
  218.         for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
  219.          --count >= 0;
  220.          Scan += 1)
  221.         {
  222.           Temp = *Scan;
  223.           Setup_Pointer_for_Dump (Transport_Quadruple ());
  224.         }
  225.         Scan -= 1;
  226.         break;
  227.       }
  228.  
  229.       case OPERATOR_LINKAGE_KIND:
  230.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  231.       {
  232.         fast long count;
  233.         fast char *word_ptr;
  234.         SCHEME_OBJECT *end_scan;
  235.  
  236.         START_OPERATOR_RELOCATION (Scan);
  237.         count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
  238.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
  239.         end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
  240.  
  241.         while(--count >= 0)
  242.         {
  243.           Scan = ((SCHEME_OBJECT *) (word_ptr));
  244.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  245.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
  246.           Dump_Compiled_Entry (after_operator);
  247.           after_operator:
  248.           STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
  249.         }
  250.         Scan = end_scan;
  251.         END_OPERATOR_RELOCATION (Scan);
  252.         break;
  253.       }
  254.  
  255.       default:
  256.       {
  257.         gc_death (TERM_EXIT,
  258.               "fasdump: Unknown compiler linkage kind.",
  259.               Scan, Free);
  260.         /*NOTREACHED*/
  261.       }
  262.     }
  263.     break;
  264.       }
  265.  
  266.       case_Cell:
  267.     Setup_Pointer_for_Dump (Transport_Cell ());
  268.     break;
  269.  
  270.       case TC_REFERENCE_TRAP:
  271.     if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  272.     {
  273.       /* It is a non pointer. */
  274.       break;
  275.     }
  276.     /* Fall through. */
  277.  
  278.       case TC_WEAK_CONS:
  279.       case_Fasdump_Pair:
  280.     Setup_Pointer_for_Dump (Transport_Pair ());
  281.     break;
  282.  
  283.       case TC_INTERNED_SYMBOL:
  284.     Setup_Pointer_for_Dump (Fasdump_Symbol (BROKEN_HEART_ZERO));
  285.     break;
  286.  
  287.       case TC_UNINTERNED_SYMBOL:
  288.     Setup_Pointer_for_Dump (Fasdump_Symbol (UNBOUND_OBJECT));
  289.     break;
  290.  
  291.       case_Triple:
  292.     Setup_Pointer_for_Dump (Transport_Triple ());
  293.     break;
  294.  
  295.       case TC_VARIABLE:
  296.     Setup_Pointer_for_Dump (Fasdump_Variable ());
  297.     break;
  298.  
  299.       case_Quadruple:
  300.     Setup_Pointer_for_Dump (Transport_Quadruple ());
  301.     break;
  302.  
  303.       case TC_BIG_FLONUM:
  304.     Setup_Pointer_for_Dump({
  305.       Transport_Flonum ();
  306.       break;
  307.     });
  308.  
  309.       case TC_COMPILED_CODE_BLOCK:
  310.       case_Purify_Vector:
  311.       process_vector:
  312.     Setup_Pointer_for_Dump (Transport_Vector ());
  313.     break;
  314.  
  315.       case TC_ENVIRONMENT:
  316.     if (mode == 1)
  317.       goto process_vector;
  318.     /* Make fasdump fail */
  319.     result = ERR_FASDUMP_ENVIRONMENT;
  320.     goto exit_dumploop;
  321.  
  322.       case TC_FUTURE:
  323.     Setup_Pointer_for_Dump (Transport_Future ());
  324.     break;
  325.  
  326.       default:
  327.     GC_BAD_TYPE ("dumploop");
  328.     /* Fall Through */
  329.  
  330.       case TC_STACK_ENVIRONMENT:
  331.       case_Fasload_Non_Pointer:
  332.     break;
  333.       }
  334.   }
  335.   result = PRIM_DONE;
  336.  
  337. exit_dumploop:
  338.   NewFree = To;
  339.   Fixup = Fixes;
  340.   return (result);
  341. }
  342.  
  343. #define DUMPLOOP(obj, mode)                        \
  344. {                                    \
  345.   long value;                                \
  346.                                     \
  347.   value = (DumpLoop (obj, mode));                    \
  348.   if (value != PRIM_DONE)                        \
  349.   {                                    \
  350.     PRIMITIVE_RETURN (Fasdump_Exit (value, false));            \
  351.   }                                    \
  352. }
  353.  
  354. #define FASDUMP_INTERRUPT()                        \
  355. {                                    \
  356.   PRIMITIVE_RETURN (Fasdump_Exit (PRIM_INTERRUPT, false));        \
  357. }
  358.  
  359. SCHEME_OBJECT
  360. DEFUN (Fasdump_Exit, (code, close_p), long code AND Boolean close_p)
  361. {
  362.   Boolean result;
  363.   fast SCHEME_OBJECT *Fixes;
  364.  
  365.   Fixes = Fixup;
  366.   if (close_p)
  367.   {
  368.     OS_channel_close_noerror (dump_channel);
  369.   }
  370.   result = true;
  371.   while (Fixes != NewMemTop)
  372.   {
  373.     fast SCHEME_OBJECT *Fix_Address;
  374.  
  375.     Fix_Address = (OBJECT_ADDRESS (*Fixes++)); /* Where it goes. */
  376.     *Fix_Address = *Fixes++;             /* Put it there. */
  377.   }
  378.   Fixup = Fixes;
  379.   if ((close_p) && ((!result) || (code != PRIM_DONE)))
  380.   {
  381.     OS_file_remove (dump_file_name);
  382.   }
  383.   dump_file_name = ((char *) 0);
  384.   Fasdump_Exit_Hook ();
  385.   if (!result)
  386.   {
  387.     signal_error_from_primitive (ERR_IO_ERROR);
  388.     /*NOTREACHED*/
  389.   }
  390.   if (code == PRIM_DONE)
  391.   {
  392.     return (SHARP_T);
  393.   }
  394.   else if (code == PRIM_INTERRUPT)
  395.   {
  396.     return (SHARP_F);
  397.   }
  398.   else
  399.   {
  400.     signal_error_from_primitive (code);
  401.     /*NOTREACHED*/
  402.   }
  403. }
  404.  
  405. /* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
  406.  
  407.    Dump an object into a file so that it can be loaded using
  408.    BINARY-FASLOAD.  A spare heap is required for this operation.  The
  409.    first argument is the object to be dumped.  The second is the
  410.    filename or channel.  The primitive returns #T or #F indicating
  411.    whether it successfully dumped the object (it can fail on an object
  412.    that is too large).  It should signal an error rather than return
  413.    false, but ... some other time.
  414.  
  415.    The third argument, FLAG, specifies how to handle the dumping of
  416.    environment objects:
  417.    - SHARP_F means that it is an error to dump an object containing
  418.    environment objects.
  419.    - SHARP_T means that they should be dumped as if they were ordinary
  420.    objects.
  421.    - anything else means that the environment objects pointed at by
  422.    compiled code blocks should be eliminated on the dumped copy,
  423.    but other environments are not allowed.
  424. */
  425.  
  426. DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
  427. {
  428.   Tchannel channel;
  429.   Boolean arg_string_p;
  430.   SCHEME_OBJECT Object, *New_Object, arg2, flag;
  431.   SCHEME_OBJECT *table_start, *table_end;
  432.   long Length, table_length;
  433.   Boolean result;
  434.   PRIMITIVE_HEADER (3);
  435.  
  436.   Object = (ARG_REF (1));
  437.   arg2 = (ARG_REF (2));
  438.   arg_string_p = (STRING_P (arg2));
  439.   if (!arg_string_p)
  440.   {
  441.     channel = (arg_channel (2));
  442.   }
  443.   flag = (ARG_REF (3));
  444.  
  445.   compiled_code_present_p = false;
  446.  
  447.   table_end = &Free[(Space_Before_GC ())];
  448.   table_start = (initialize_primitive_table (Free, table_end));
  449.   if (table_start >= table_end)
  450.   {
  451.     Primitive_GC (table_start - Free);
  452.   }
  453.  
  454.   Fasdump_Free_Calc (NewFree, NewMemTop, Orig_New_Free);
  455.   Fixup = NewMemTop;
  456.   ALIGN_FLOAT (NewFree);
  457.   New_Object = NewFree;
  458.   *NewFree++ = Object;
  459.  
  460.   if (arg_string_p)
  461.   {
  462.     /* This needs to be done before Fasdump_Exit is called.
  463.        DUMPLOOP may do that.
  464.        It should not be done if the primitive will not call
  465.        Fasdump_Exit on its way out (ie. Primitive_GC above).
  466.      */
  467.     dump_file_name = ((CONST char *) (STRING_LOC (arg2, 0)));
  468.   }
  469.  
  470.   DUMPLOOP (New_Object,
  471.         ((flag == SHARP_F) ? 0 : ((flag == SHARP_T) ? 1 : 2)));
  472.   Length = (NewFree - New_Object);
  473.   table_start = NewFree;
  474.   table_end = (cons_primitive_table (NewFree, Fixup, &table_length));
  475.   if (table_end >= Fixup)
  476.   {
  477.     FASDUMP_INTERRUPT ();
  478.   }
  479.  
  480.   if (arg_string_p)
  481.   {
  482.     channel = (OS_open_dump_file (dump_file_name));
  483.     if (channel == NO_CHANNEL)
  484.     {
  485.       PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
  486.     }
  487.   }
  488.  
  489.   dump_channel = channel;
  490.   result = (Write_File (New_Object,
  491.             Length, New_Object,
  492.             0, Constant_Space,
  493.             table_start, table_length,
  494.             ((long) (table_end - table_start)),
  495.             compiled_code_present_p, false));
  496.  
  497.   PRIMITIVE_RETURN (Fasdump_Exit ((result ? PRIM_DONE : PRIM_INTERRUPT),
  498.                   arg_string_p));
  499. }
  500.  
  501. /* (DUMP-BAND PROCEDURE FILE-NAME)
  502.    Saves all of the heap and pure space on FILE-NAME.  When the
  503.    file is loaded back using BAND_LOAD, PROCEDURE is called with an
  504.    argument of #F.
  505. */
  506.  
  507. DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
  508. {
  509.   SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free;
  510.   long table_length;
  511.   Boolean result;
  512.   PRIMITIVE_HEADER (2);
  513.   Band_Dump_Permitted ();
  514.   CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
  515.   CHECK_ARG (2, STRING_P);
  516.   if (Unused_Heap < Heap_Bottom)
  517.   {
  518.     /* Cause the image to be in the low heap, to increase
  519.        the probability that no relocation is needed on reload. */
  520.     Primitive_GC (0);
  521.   }
  522.   Primitive_GC_If_Needed (5);
  523.   saved_free = Free;
  524.   Combination = MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free);
  525.   Free[COMB_1_FN] = (ARG_REF (1));
  526.   Free[COMB_1_ARG_1] = SHARP_F;
  527.   Free += 2;
  528.   *Free++ = Combination;
  529.   *Free++ = compiler_utilities;
  530.   *Free = MAKE_POINTER_OBJECT (TC_LIST, (Free - 2));
  531.   Free++;  /* Some compilers are TOO clever about this and increment Free
  532.           before calculating Free-2! */
  533.   table_start = Free;
  534.   table_end = cons_whole_primitive_table(Free, Heap_Top, &table_length);
  535.   if (table_end >= Heap_Top)
  536.   {
  537.     result = false;
  538.   }
  539.   else
  540.   {
  541.     CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
  542.     OS_file_remove_link (filename);
  543.     dump_channel = (OS_open_dump_file (filename));
  544.     if (dump_channel == NO_CHANNEL)
  545.       error_bad_range_arg (2);
  546.     result = Write_File((Free - 1),
  547.             ((long) (Free - Heap_Bottom)), Heap_Bottom,
  548.             ((long) (Free_Constant - Constant_Space)),
  549.             Constant_Space,
  550.             table_start, table_length,
  551.             ((long) (table_end - table_start)),
  552.             (compiler_utilities != SHARP_F), true);
  553.     /* The and is short-circuit, so it must be done in this order. */
  554.     OS_channel_close_noerror (dump_channel);
  555.     if (!result)
  556.       OS_file_remove (filename);
  557.   }
  558.   Band_Dump_Exit_Hook ();
  559.   Free = saved_free;
  560.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
  561. }
  562.